home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
ezy_comm
/
ezy1023.zip
/
EKIT102.ZIP
/
EZYINC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-10-24
|
13KB
|
552 lines
(* EZYINC V1.00 - An Ezycom General Purpose TP Unit
Copyright Peter Davies 1992. All Rights Reserved.
This source may be freely used as long as due credit is given.
That means, in your documentation, you MUST acknowledge that
"EZYINC Copyright Peter Davies 1992" was used.
EZYINC is a general purpose unit for Ezycom Utilities
Simply add EZYINC to your uses statement
Features: General Purpose Procedures
Automatic Reading of CONFIG.EZY into configrec
-N<node> and/or TASK aware
(node number stored in "node")
Inline Assembly on highly used routines *)
unit ezyinc;
{$F+,R-,S-,V-}
Interface
uses Crt, dos;
{$I struct}
procedure setbit(position, value : byte; var changebyte : byte);
procedure setbitbyte(position : byte;value : boolean;var changebyte : byte);
(* Set a Bit at Position <0-7> to On=1 or Off=0 *)
procedure setbitword(position : byte;value : boolean; var changeword : word);
(* Set a Bit at Position <0-15> to Value *)
function biton(position : byte;testword : word) : boolean;
(* Test if Bit Position <0-15> is on in TestWord
Note: Also works on Bytes *)
function itospad(x : longint;padout : byte) : str12;
(* Returns a String from a Number, padded with leading 0s padout size *)
function itos(x : longint) : str12;
(* Returns a String from a Number *)
function dig2(s : word) : str2;
(* Return a 2 Digit String ranging 00 to 99 *)
function low2up(line : maxstr) : maxstr;
(* Convert Lowercase to Uppercase *)
function find(path : maxstr) : boolean;
(* Returns True if PATH exists *)
function findw(s : maxstr) : maxstr;
(* Returns the Path and filename of a Configuration File(s) *)
function parfind(line : maxstr) : boolean;
(* Returns true if it finds LINE in the parameters *)
function getparam(line : maxstr) : string;
(* Returns the remaining portion of LINE in paramaters *)
function st_trail(s : maxstr) : maxstr;
(* Strips Trailing Spaces *)
function addslash(line : maxstr) : maxstr;
(* Adds a Slash if not there to LINE *)
function remslash(line : maxstr) : maxstr;
(* Removes the Slash if there in LINE *)
function checkdate(yy,mm,dd : word) : boolean;
(* Checks for a Valid Date *)
function wordtodate(temp : word;var yy,mm,dd : word) : boolean;
(* Converts a Word to Date Format *)
function datetoword(yy,mm,dd : word) : word;
(* Converts a Date to a Word Format *)
function st_lead(s : maxstr) : maxstr;
(* Removes leading SPACES from a string *)
function retmessxxx(msgboard : word;t : byte) : maxstr;
(* Returns the FULL path to a message area
On entry if T = 1 then the Header Path is returned
if T = 2 then the Text Path is returned *)
function retfilexxx(filearea : word) : maxstr;
(* Returns the FULL path to a file area *)
var
systempath : maxstr; { Path to System Files }
node : byte; { Node Number -N<1..250> }
configrec : configrecord; { Configuration }
constant : constantrecord; { Constant }
implementation
{$IFDEF Ver60} (* if turbo pascal V6.0 *)
function biton(position : byte;testword : word) : boolean; assembler;
asm
mov ax, 1;
mov cl, position;
shl ax, cl;
and ax, testword;
jnz @notbiton
mov ax, false;
jmp @finish;
@notbiton :
mov ax, true;
@finish :
end;
{$ELSE}
function biton(position : byte;testword : word) : boolean;
var
bt : word;
begin
bt := $01;
bt := bt shl position;
biton := (bt and testword) > 0;
end;
{$ENDIF}
procedure setbitword(position : byte;value : boolean;var changeword : word);
(* Set a Bit at Position <0-15> to Value *)
var
wd : word;
begin
wd := $01;
wd := wd shl position;
if value then
changeword := changeword or wd else
begin
wd := wd xor $ff;
changeword := changeword and wd;
end;
end;
procedure setbitbyte(position : byte;value : boolean;var changebyte : byte);
(* Set a Bit at Position <0-7> to Value *)
var
wd : byte;
begin
wd := $01;
wd := wd shl position;
if value then
changebyte := changebyte or wd else
begin
wd := wd xor $ff;
changebyte := changebyte and wd;
end;
end;
procedure setbit(position, value : byte; var changebyte : byte);
var
bt : byte;
begin
bt := $01;
bt := bt shl position;
if value = 1 then
changebyte := changebyte or bt else
begin
bt := bt xor $ff;
changebyte := changebyte and bt;
end;
end;
function find(path : maxstr) : boolean;
var
srec : searchrec;
begin
findfirst(path,anyfile,srec);
find := (doserror = 0);
end;
function itospad(x : longint;padout : byte) : str12;
var
temp : str12;
begin
str(x:padout,temp);
for padout := 1 to length(temp) do
if (temp[padout] = ' ') then
temp[padout] := '0';
itospad := temp;
end;
function dig2(s : word) : str2;
begin
dig2 := itospad(s,2);
end;
function ItoS(x : longint) : str12;
var
temp : string[12];
begin
str(x,temp);
itos := temp;
end;
function low2up(line : maxstr) : maxstr;
{var
loop : integer;}
begin
{ for loop := 1 to length(line) do ***** Pascal Equivalent *****
line[loop] := upcase(line[loop]);
low2up := line;}
INLINE(
$1E/
$C5/$76/$06/
$C4/$7E/$0A/
$FC/
$AC/
$AA/
$30/$ED/
$88/$C1/
$E3/$0E/
$AC/
$3C/$61/
$72/$06/
$3C/$7A/
$77/$02/
$2C/$20/
$AA/
$E2/$F2/
$1F);
end;
function findw(s : maxstr) : maxstr;
begin
if find(systempath + s + '.' + itos(node)) then
findw := systempath + s + '.' + itos(node) else
if find(s + '.EZY') then
findw := s + '.EZY' else
findw := systempath + s + '.EZY';
end;
function getparam(line : maxstr) : string;
var
loop : integer;
found : boolean;
posstart : byte;
begin
loop := 1;
found := false;
while (loop <= paramcount) and (not found) do
begin
posstart := pos(line,low2up(paramstr(loop)));
if (posstart = 1) then
found := true else
loop := loop + 1;
end;
if found then
getparam := copy(paramstr(loop),posstart+length(line),255) else
getparam := '';
end;
function st_trail(s : maxstr) : maxstr;
{var
loop : integer;
alpha : boolean;}
begin
{ alpha := false;
for loop := length(s) downto 1 do **** Pascal Equivalent ****
if (s[loop] = ' ') and (not alpha) then
s[0] := chr(ord(s[0]) -1) else
alpha := true;
st_trail := s; }
INLINE(
$1E/
$C5/$76/$06/
$FC/
$AC/
$3C/$00/
$74/$21/
$30/$ED/
$88/$C1/
$B0/$20/
$C4/$7E/$06/
$01/$CF/
$FD/
$F3/$AE/
$74/$01/
$41/
$88/$C8/
$C5/$76/$06/
$46/
$C4/$7E/$0A/
$FC/
$AA/
$F2/$A4/
$E9/$04/$00/
$C4/$7E/$0A/
$AA/
$1F);
end;
function st_lead(s : maxstr) : maxstr;
var
loop : word;
slength : byte absolute s;
begin
loop := 1;
while (loop <= slength) and (s[loop] = ' ') do
inc(loop);
dec(loop);
if (loop > 0) then
delete(s, 1, loop);
st_lead := s;
end;
function addslash(line : maxstr) : maxstr;
var
llen : byte absolute line;
begin
line := st_trail(line);
if (llen > 0) and (line[llen] <> '\') then
begin
inc(llen);
line[llen] := '\';
end;
addslash := line;
end;
function remslash(line : maxstr) : maxstr;
var
llen : byte absolute line;
begin
if (length(line) > 0) and (line[length(line)] = '\') then
dec(llen);
remslash := line;
end;
function parfind(line : maxstr) : boolean;
var
loop : integer;
found : boolean;
begin
loop := 1;
found := false;
while (loop <= paramcount) and (not found) do
if pos(line,low2up(paramstr(loop))) = 1 then
found := true else
loop := loop + 1;
parfind := found;
end;
function checkdate(yy,mm,dd : word) : boolean;
const
daysinmonth : array[1..12] of word =
(31,29,31,30,31,30,31,31,30,31,30,31);
begin
checkdate := false;
if (mm < 1) or (mm > 12) then
exit;
if (dd < 1) or (dd > daysinmonth[mm]) then
exit;
if not ((yy mod 4 <> 0) and (dd = 29) and (mm=2)) then
checkdate := true;
end;
function datetoword(yy,mm,dd : word) : word;
var
tofield : word;
tempbyte : byte;
begin
datetoword := 65535;
if not checkdate(yy,mm,dd) then
exit;
tofield := dd - 1;
tofield := tofield + ((mm - 1) shl 5);
if (yy < 1980) or (yy > (1980 + 127)) then
exit;
yy := yy - 1980;
tofield := tofield + (yy shl 9);
datetoword := tofield;
end;
function wordtodate(temp : word;var yy,mm,dd : word) : boolean;
begin
if (temp = 65535) then
begin
wordtodate := false;
exit;
end else
wordtodate := true;
dd := temp and 31 + 1;
temp := temp shr 5;
mm := temp and 15 + 1;
temp := temp shr 4;
yy := (temp and 127) + 1980;
end;
function retmessxxx(msgboard : word;t : byte) : maxstr;
var
temp : string[3];
temp2 : string[3];
begin
temp := itospad(msgboard,3);
str(((msgboard-1) div 100) + 1,temp2);
if t = 1 then
retmessxxx := configrec.msgpath + 'AREA' + temp2 + '\MSGH' + temp + '.BBS' else
retmessxxx := configrec.msgpath + 'AREA' + temp2 + '\MSGT' + temp + '.BBS';
end;
function retfilexxx(filearea : word) : maxstr;
var
temp : string[3];
temp2 : string[3];
begin
temp := itospad(filearea,3);
str(((filearea-1) div 100) + 1,temp2);
retfilexxx := configrec.filepath + 'AREA' + temp2 + '\FILE' + temp + '.BBS';
end;
procedure newsetup;
var
tempfile : file;
tempstr : maxstr;
error : integer;
begin
systempath := getenv('EZY');
if (length(systempath) = 0) then
getdir(0,systempath);
systempath := fexpand(addslash(low2up(systempath)));
node := 1;
tempstr := getenv('TASK');
if (length(tempstr) > 0) then
begin
val(tempstr,node,error);
if (error > 0) or (node = 0) then
node := 1 else
if (node > 250) then
node := 250;
end;
tempstr := getparam('-N');
if (length(tempstr) > 0) then
begin
val(tempstr,node,error);
if (error > 0) or (node = 0) then
node := 1 else
if (node > 250) then
node := 250;
end;
tempstr := findw('CONFIG');
if not find(tempstr) then
begin
if (doserror = 3) then
begin
writeln(chr(254) + ' System Path Invalid.');
writeln(chr(254) + ' Please Change EZY Environment Variable.');
halt(1);
end;
writeln(chr(254) + ' CONFIG.EZY not found');
writeln(chr(254) + ' Use CONFIG.EXE to Create it');
halt(1);
end;
if not find(systempath + 'CONSTANT.EZY') then
begin
writeln(chr(254) + ' CONSTANT.EZY not found');
writeln(chr(254) + ' Use CONFIG.EXE to Create it');
halt(1);
end;
filemode := fdenynone + freadonly;
assign(tempfile,systempath + 'CONSTANT.EZY');
{$I-}
repeat
reset(tempfile,sizeof(constantrecord));
error := ioresult;
if (error = 5) then
delay(500) else
if (error <> 0) then
runerror(error);
until (error = 0);
{$I+}
blockread(tempfile,constant,1);
close(tempfile);
filemode := fdenynone + freadonly;
assign(tempfile,tempstr);
{$I-}
repeat
reset(tempfile,sizeof(configrec));
error := ioresult;
if (error = 5) then
delay(500) else
if (error <> 0) then
runerror(error);
until (error = 0);
{$I+}
blockread(tempfile,configrec,1);
close(tempfile);
checksnow := configrec.snow_check;
end;
begin
if (LastMode <> CO80) and (LastMode <> BW80) and
(LastMode <> Mono) then
TextMode(CO80);
directvideo := false;
textattr := 7;
newsetup;
end.